COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00003 00003	.s(LCOMap,LISP Compilers)
C00010 00004	.next page
C00024 ENDMK
C⊗;
.s(LCOMap,LISP Compilers)
.ss(lcom0mcl,LCOM0: listing of MACLISP version.)
.BEGIN "Appendix LCOM0"
.VERBATIM SELECT 7

(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (READ))

(DEFPROP LC0FNS
 (LC0FNS COMPL COMP PRUP MKPUSH COMPEXP COMPLIS LOADAC COMCOND COMBOOL COMPANDOR)
VALUE)

(DEFPROP COMPL
 (LAMBDA(FILE)
  (UWRITE)
  (APPLY (QUOTE EREAD) FILE)
  (SELECT-DISK-INPUT
   (READ-UNTIL-EOF
    WITH
    Z
    DO
    (COND ((OR (EQ (CAR Z) (QUOTE DEFUN)) (AND (EQ (CAR Z) (QUOTE DEFPROP)) (EQ (CADDDR Z) (QUOTE EXPR))))
	   (PROG (PROG)
		 (SETQ PROG
		       (COND ((EQ (CAR Z) (QUOTE DEFUN)) (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
			     (T (COMP (CADR Z) (CADR (CADDR Z)) (CADDR (CADDR Z))))))
		 (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		 (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	  (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
   (APPLY (QUOTE UFILE) (LIST (CAR FILE) (QUOTE LAP)))
   (QUOTE ENDCOMP)))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(N)
    (APPEND (LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
	    (MKPUSH N 1)
	    (COMPEXP EXP (MINUS N) (PRUP VARS 1))
	    (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))
	    (QUOTE ((POPJ P) NIL))))
   (LENGTH VARS)))
EXPR)

(DEFPROP PRUP
 (LAMBDA (VARS N) (COND ((NULL VARS) NIL) (T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (ADD1 N))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA (N M) (COND ((LESSP N M) NIL) (T (CONS (LIST (QUOTE PUSH) (QUOTE P) M) (MKPUSH N (ADD1 M))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((EQ EXP T) (QUOTE ((MOVEI 1 (QUOTE T)))))
	((NUMBERP EXP) (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP) (LIST (LIST (QUOTE MOVE) 1 (PLUS M (CDR (ASSOC EXP VPR))) (QUOTE P))))
	((OR (EQ (CAR EXP) (QUOTE AND)) (EQ (CAR EXP) (QUOTE OR)) (EQ (CAR EXP) (QUOTE NOT)))
	 ((LAMBDA(L1 L2)
	   (APPEND (COMBOOL EXP M L1 NIL VPR)
		   (LIST (QUOTE (MOVEI 1 (QUOTE T))) (LIST (QUOTE JRST) 0 L2) L1 (QUOTE (MOVEI 1 0)) L2)))
	  (GENSYM)
	  (GENSYM)))
	((EQ (CAR EXP) (QUOTE COND)) (COMCOND (CDR EXP) M (GENSYM) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE)) (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 ((LAMBDA(N)
	   (APPEND (COMPLIS (CDR EXP) M VPR)
		   (LOADAC (DIFFERENCE 1 N) 1)
		   (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))
		   (LIST (LIST (QUOTE CALL) N (LIST (QUOTE QUOTE) (CAR EXP))))))
	  (LENGTH (CDR EXP))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (APPEND (COMPLIS (CDR EXP) M VPR)
		   (COMPEXP (CADDAR EXP) 
                            (DIFFERENCE M N) 
                            (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
		   (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))))
	  (LENGTH (CDR EXP))))
	(T NIL)))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(U M VPR)
  (COND	((NULL U) NIL)
	(T (APPEND (COMPEXP (CAR U) M VPR) (QUOTE ((PUSH P 1))) (COMPLIS (CDR U) (SUB1 M) VPR)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(N K)
  (COND ((GREATERP N 0) NIL) (T (CONS (LIST (QUOTE MOVE) K N (QUOTE P)) (LOADAC (ADD1 N) (ADD1 K))))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L VPR)
  (COND	((NULL U) (LIST L))
	(T
	 ((LAMBDA(L1)
	   (APPEND (COMBOOL (CAAR U) M L1 NIL VPR)
		   (COMPEXP (CADAR U) M VPR)
		   (LIST (LIST (QUOTE JRST) 0 L) L1)
		   (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG VPR)
  (COND	((ATOM P) 
         (APPEND (COMPEXP P M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA(L1)
		  (APPEND (COMPANDOR (CDR P) M L1 NIL VPR) (LIST (LIST (QUOTE JRST) 0 L)) (LIST L1)))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA (L1) 
                  (APPEND (COMPANDOR (CDR P) M L1 T VPR) (LIST (LIST (QUOTE JRST) 0 L)) (LIST L1)))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE NOT)) (COMBOOL (CADR P) M L (NOT FLG) VPR))
	(T (APPEND (COMPEXP P M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG VPR)
  (COND ((NULL U) NIL) (T (APPEND (COMBOOL (CAR U) M L FLG VPR) (COMPANDOR (CDR U) M L FLG VPR)))))
EXPR)
.END "appendix LCOM0"
.next page
.ss(lcom4mcl,LCOM4: listing of MACLISP version.)
.BEGIN "Appendix LCOM4"
.VERBATIM SELECT 7

(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (READ))

(DEFPROP COMPFCNS
 (COMPFCNS COMPL
	   COMP
	   SUBSTACK
	   PRUP
	   MKPUSH
	   COMPEXP
	   STACKUP
	   CCCHAIN
	   COMPC
	   COMCOND
	   COMPLISA
	   CCOUNT
	   LOADAC
	   COMPLIS
	   CLASSIFY
	   CLASS1
	   CLASS2
	   MKJRST
	   COMBOOL
	   COMPANDOR
	   COMPANDOR1
	   FLAT)
VALUE)

(DEFPROP COMPL
 (LAMBDA(FILE)
  (UWRITE)
  (APPLY (QUOTE EREAD) FILE)
  (SELECT-DISK-INPUT
   (READ-UNTIL-EOF
    WITH
    Z
    DO
    (COND ((OR (EQ (CAR Z) (QUOTE DEFUN)) (AND (EQ (CAR Z) (QUOTE DEFPROP)) (EQ (CADDDR Z) (QUOTE EXPR))))
	   (PROG (PROG)
		 (SETQ PROG
		       (COND ((EQ (CAR Z) (QUOTE DEFUN)) (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
			     (T (COMP (CADR Z) (CADR (CADDR Z)) (CADDR (CADDR Z))))))
		 (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		 (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	  (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
   (APPLY (QUOTE UFILE) (LIST (CAR FILE) (QUOTE LAP)))
   (QUOTE ENDCOMP)))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(VPR N)
    (FLAT (LIST	(LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
		(MKPUSH N 1)
		(COMPEXP EXP (MINUS N) VPR)
		(SUBSTACK N)
		(QUOTE ((POPJ P) (LABEL NIL))))
	  NIL))
   (PRUP VARS 1)
   (LENGTH VARS)))
EXPR)

(DEFPROP SUBSTACK
 (LAMBDA (N) (COND ((= N 0) NIL) (T (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N))))))
EXPR)

(DEFPROP PRUP
 (LAMBDA (VARS N) (COND ((NULL VARS) NIL) (T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (ADD1 N))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA (N M) (COND ((LESSP N M) NIL) (T (CONS (LIST (QUOTE PUSH) (QUOTE P) M) (MKPUSH N (ADD1 M))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((OR (EQ EXP T) (NUMBERP EXP)) (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP) (LIST (LIST (QUOTE MOVE) 1 (PLUS M (CDR (ASSOC EXP VPR))) (QUOTE P))))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP)) 
		(LIST (LIST (QUOTE HLRZ) 1 (QUOTE @)(PLUS M (CDR (ASSOC (CADR EXP) VPR))) (QUOTE P))))
	       (T (LIST (COMPEXP (CADR EXP) M VPR) (QUOTE ((HLRZ 1 @ 1)))))))
	((EQ (CAR EXP) (QUOTE CDR))
	 (COND ((ATOM (CADR EXP)) 
		(LIST (LIST (QUOTE HRRZ) 1 (QUOTE @)(PLUS M (CDR (ASSOC (CADR EXP) VPR))) (QUOTE P))))
	       (T (LIST (COMPEXP (CADR EXP) M VPR) (QUOTE ((HRRZ 1 @ 1)))))))
	((OR (EQ (CAR EXP) (QUOTE AND))
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT))
	     (EQ (CAR EXP) (QUOTE EQ)))
	 ((LAMBDA(L1 L2)
	   (LIST (COMBOOL EXP M L1 NIL VPR)
		 (LIST (QUOTE (MOVEI 1 (QUOTE T)))
		       (LIST (QUOTE JRST) 0 L2)
		       (LIST (QUOTE LABEL) L1)
		       (QUOTE (MOVEI 1 0))
		       (LIST (QUOTE LABEL) L2))))
	  (GENSYM)
	  (GENSYM)))
	((EQ (CAR EXP) (QUOTE COND)) (COMCOND (CDR EXP) M (GENSYM) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE)) (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 (LIST (COMPLISA (CDR EXP) M VPR)
	       (LIST (LIST (QUOTE CALL) (LENGTH (CDR EXP)) (LIST (QUOTE QUOTE) (CAR EXP))))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (LIST (STACKUP (CDR EXP) M VPR)
		 (COMPEXP (CADDAR EXP) (DIFFERENCE M N) (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
		 (SUBSTACK N)))
	  (LENGTH (CDR EXP))))
	(T NIL)))
EXPR)

(DEFPROP STACKUP
 (LAMBDA(U M VPR)
  (COND ((NULL U) NIL) 
        (T (LIST (COMPEXP (CAR U) M VPR) (QUOTE ((PUSH P 1))) (STACKUP (CDR U) (SUB1 M) VPR)))))
EXPR)

(DEFPROP CCCHAIN
 (LAMBDA(EXP)
  (AND (OR (EQ (CAR EXP) (QUOTE CAR)) (EQ (CAR EXP) (QUOTE CDR))) 
       (OR (ATOM (CADR EXP)) (CCCHAIN (CADR EXP)))))
EXPR)

(DEFPROP COMPC
 (LAMBDA(EXP N2 M VPR)
  (COND	((ATOM EXP) (ERROR (QUOTE COMPC)))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST (LIST (QUOTE HLRZ) N2 (QUOTE @)(PLUS M (CDR (ASSOC (CADR EXP) VPR))) (QUOTE P))))
	       (T (CONS (LIST (QUOTE HLRZ) N2 (QUOTE @) N2) (COMPC (CADR EXP) N2 M VPR)))))
	((ATOM (CADR EXP)) 
         (LIST (LIST (QUOTE HRRZ) (QUOTE @) N2 (PLUS M (CDR (ASSOC (CADR EXP) VPR))) (QUOTE P))))
	(T (CONS (LIST (QUOTE HRRZ) N2 (QUOTE @) N2) (COMPC (CADR EXP) N2 M VPR)))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L VPR)
  (COND	((NULL U) (LIST (LIST (QUOTE LABEL) L)))
	((AND (NOT (ATOM (CAAR U))) (EQ (CAAAR U) (QUOTE NULL)) (NULL (CADAR U)))
	 (LIST (COMPEXP (CADAAR U) M VPR) (LIST (LIST (QUOTE JUMPE) 1 L)) (COMCOND (CDR U) M L VPR)))
	((EQ (CAAR U) T) (LIST (COMPEXP (CADAR U) M VPR) (LIST (LIST (QUOTE LABEL) L))))
	(T
	 ((LAMBDA(L1)
	   (LIST (COMBOOL (CAAR U) M L1 NIL VPR)
		 (COMPEXP (CADAR U) M VPR)
		 (LIST (LIST (QUOTE JRST) 0 L) (LIST (QUOTE LABEL) L1))
		 (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))
EXPR)

(DEFPROP COMPLISA
 (LAMBDA(U M VPR)
  ((LAMBDA(Z)
    (LIST (COMPLIS Z M 1 VPR)
	  (LOADAC Z (DIFFERENCE 1 (CCOUNT Z)) 1 (DIFFERENCE M (CCOUNT Z)) VPR)
	  (SUBSTACK (CCOUNT Z))))
   (CLASSIFY U)))
EXPR)

(DEFPROP CCOUNT
 (LAMBDA (Z) (COND ((NULL Z) 0) ((= (CAAR Z) 4) (ADD1 (CCOUNT (CDR Z)))) (T (CCOUNT (CDR Z)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(Z M2 N2 M VPR)
  (COND	((NULL Z) NIL)
	((= (CAAR Z) 1)
	 (CONS (LIST (QUOTE MOVE) N2 (PLUS M (CDR (ASSOC (CDAR Z) VPR))) (QUOTE P))
	       (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 0)
	 (CONS (LIST (QUOTE MOVEI) N2 (LIST (QUOTE QUOTE) (CDAR Z))) (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 2) (CONS (LIST (QUOTE MOVEI) N2 (CDAR Z)) (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 3) (LIST (REVERSE (COMPC (CDAR Z) N2 M VPR)) (LOADAC (CDR Z) M2 (ADD1 N2) M VPR)))
	((= (CAAR Z) 5) (LOADAC (CDR Z) 1 (ADD1 N2) M VPR))
	(T (CONS (LIST (QUOTE MOVE) N2 M2 (QUOTE P)) (LOADAC (CDR Z) (ADD1 M2) (ADD1 N2) M VPR)))))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(Z M K VPR)
  (COND	((NULL Z) NIL)
	((= (CAAR Z) 4)
	 (LIST (COMPEXP (CDAR Z) M VPR) (QUOTE ((PUSH P 1))) (COMPLIS (CDR Z) (SUB1 M) (ADD1 K) VPR)))
	((= (CAAR Z) 5) 
         (LIST (COMPEXP (CDAR Z) M VPR) (COND ((= K 1) NIL) (T (LIST (LIST (QUOTE MOVE) K 1))))))
	(T (COMPLIS (CDR Z) M (ADD1 K) VPR))))
EXPR)

(DEFPROP CLASSIFY
 (LAMBDA (U) (CLASS2 (CLASS1 U NIL) NIL T))
EXPR)

(DEFPROP CLASS1
 (LAMBDA(U V)
  (COND	((NULL U) V)
	((ATOM (CAR U))
	 (COND ((OR (EQUAL (CAR U) NIL) (EQUAL (CAR U) T) (NUMBERP (CAR U)))
		(CLASS1 (CDR U) (CONS (CONS 0 (CAR U)) V)))
	       (T (CLASS1 (CDR U) (CONS (CONS 1 (CAR U)) V)))))
	((EQUAL (CAAR U) (QUOTE QUOTE)) (CLASS1 (CDR U) (CONS (CONS 2 (CAR U)) V)))
	((CCCHAIN (CAR U)) (CLASS1 (CDR U) (CONS (CONS 3 (CAR U)) V)))
	(T (CLASS1 (CDR U) (CONS (CONS 4 (CAR U)) V)))))
EXPR)

(DEFPROP CLASS2
 (LAMBDA(U V FLG)
  (COND	((NULL U) V)
	((AND FLG (= (CAAR U) 4)) (CLASS2 (CDR U) (CONS (CONS 5 (CDAR U)) V) NIL))
	(T (CLASS2 (CDR U) (CONS (CAR U) V) FLG))))
EXPR)

(DEFPROP MKJRST
 (LAMBDA (L) (LIST (LIST (QUOTE JRST) 0 L)))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG VPR)
  (COND	((EQ P T) (COND (FLG (MKJRST L)) (T NIL)))
	((ATOM P) (LIST (COMPEXP P M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))
	((EQ (CAR P) (QUOTE EQ))
	 (LIST (COMPLISA (CDR P) M VPR) 
               (COND (FLG (QUOTE ((CAMN 1 2)))) (T (QUOTE ((CAME 1 2))))) 
               (MKJRST L)))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA (L1) (LIST (COMPANDOR1 (CDR P) M L1 L NIL VPR) (LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA (L1) (LIST (COMPANDOR1 (CDR P) M L1 L T VPR) (LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE NOT)) (COMBOOL (CADR P) M L (NOT FLG) VPR))
	((EQ (CAR P) (QUOTE NULL))
	 (LIST (COMPEXP (CADR P) M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPE)) (T (QUOTE JUMPN))) 1 L))))
	(T (LIST (COMPEXP P M VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG VPR)
  (COND ((NULL U) NIL) (T (LIST (COMBOOL (CAR U) M L FLG VPR) (COMPANDOR (CDR U) M L FLG VPR)))))
EXPR)

(DEFPROP COMPANDOR1
 (LAMBDA(U M L L2 FLG VPR)
  (COND	((NULL U) (MKJRST L2))
	((NULL (CDR U)) (COMBOOL (CAR U) M L2 (NOT FLG) VPR))
	(T (LIST (COMBOOL (CAR U) M L FLG VPR) (COMPANDOR1 (CDR U) M L L2 FLG VPR)))))
EXPR)

(DEFPROP FLAT
 (LAMBDA(U S)
  (COND	((NULL U) S)
	((NULL (CAR U)) (FLAT (CDR U) S))
	((EQ (CAR U) (QUOTE LABEL)) (CONS (CADR U) S))
	((ATOM (CAR U)) (CONS U S))
	(T (FLAT (CAR U) (FLAT (CDR U) S)))))
EXPR)
.END "appendix LCOM4"